home *** CD-ROM | disk | FTP | other *** search
/ Gamers Delight 2 / Gamers Delight 2.iso / Aminet / game / misc / PuzzlePro.lha / PuzzlePro / Puzzle Maker v1.0 (.txt) < prev    next >
AmigaBASIC Source Code  |  1987-12-31  |  7KB  |  254 lines
  1. CLEAR ,65000
  2. Main:
  3.  
  4. DIM bPlane&(5),cTabWork%(32),cTabSave%(32),scolor!(31,3),box%(6568),piece%(203,49),s$(49)
  5.  
  6. ccrtDir%   = 0
  7. ccrtStart% = 0
  8. ccrtEnd%   = 0
  9. ccrtSecs&  = 0
  10. ccrtMics&  = 0
  11. DECLARE FUNCTION xOpen&  LIBRARY
  12. DECLARE FUNCTION xRead&  LIBRARY
  13. DECLARE FUNCTION xWrite& LIBRARY
  14. DECLARE FUNCTION AllocMem&() LIBRARY
  15. LIBRARY "dos.library"
  16. LIBRARY "exec.library"
  17. LIBRARY "graphics.library"
  18. CLS:PRINT TAB(20);"PUZZLE MAKER v1.0 (c)1987 Oston Software"
  19. PRINT:PRINT TAB(28);"Written by Syd L. Bolton"
  20. PRINT:PRINT:PRINT "Please read 'PUZZLE.MAKER.doc' for program info and complete instructions.":PRINT 
  21. GetNames:
  22. INPUT "   IFF ILBM filespec";ILBMname$
  23. IF (ILBMname$ = "") GOTO Mcleanup2
  24. loadError$ = ""
  25. GOSUB LoadILBM
  26. IF loadError$ <> "" THEN Mcleanup
  27. IF (loadError$ = "") THEN SavePuzzle
  28. Mcleanup:
  29. WINDOW CLOSE 2
  30. SCREEN CLOSE 2
  31. Mcleanup2:
  32. LIBRARY CLOSE
  33. IF loadError$ <> "" THEN PRINT loadError$
  34. END
  35. LoadILBM:
  36. f$="df0:"+ILBMname$
  37. fHandle& = 0
  38. mybuf& = 0
  39. foundBMHD = 0
  40. foundCMAP = 0
  41. foundCAMG = 0
  42. foundCCRT = 0
  43. foundBODY = 0
  44. filename$ = f$ + CHR$(0)
  45. fHandle& = xOpen&(SADD(filename$),1005)
  46. IF fHandle& = 0 THEN
  47.    loadError$ = "Can't open/find pic file"
  48.    GOTO Lcleanup
  49. END IF
  50.  
  51. ClearPublic& = 65537
  52. mybufsize& = 360
  53. mybuf& = AllocMem&(mybufsize&,ClearPublic&)
  54. IF mybuf& = 0 THEN
  55.    loadError$ = "Can't alloc buffer"
  56.    GOTO Lcleanup
  57. END IF
  58. inbuf& = mybuf&
  59. cbuf& = mybuf& + 120
  60. ctab& = mybuf& + 240
  61. rLen& = xRead&(fHandle&,inbuf&,12)
  62. tt$ = ""
  63. FOR kk = 8 TO 11
  64.    tt% = PEEK(inbuf& + kk)
  65.    tt$ = tt$ + CHR$(tt%)
  66. NEXT
  67. IF tt$ <> "ILBM" THEN 
  68.    loadError$ = "Not standard ILBM pic file"
  69.    GOTO Lcleanup
  70. END IF
  71. ChunkLoop:
  72.  rLen& = xRead&(fHandle&,inbuf&,8)
  73.  icLen& = PEEKL(inbuf& + 4)
  74.  tt$ = ""
  75.  FOR kk = 0 TO 3
  76.     tt% = PEEK(inbuf& + kk)
  77.     tt$ = tt$ + CHR$(tt%)
  78.  NEXT       
  79. IF tt$ = "BMHD" THEN
  80.    foundBMHD = 1
  81.    rLen& = xRead&(fHandle&,inbuf&,icLen&)
  82.    iWidth%  = PEEKW(inbuf&)
  83.    iHeight% = PEEKW(inbuf& + 2)
  84.    iDepth%  = PEEK(inbuf& + 8)  
  85.    iCompr%  = PEEK(inbuf& + 10)
  86.    scrWidth%  = PEEKW(inbuf& + 16)
  87.    scrHeight% = PEEKW(inbuf& + 18)
  88.    iRowBytes% = iWidth% /8
  89.    scrRowBytes% = scrWidth% / 8
  90.    nColors%  = 2^(iDepth%)
  91.    IF scrWidth%<>320 OR scrHeight%<>200 OR nColors%<>32 THEN loadError$="Must be 320X200 5 bit-plane image.":GOTO Lcleanup   
  92.    AvailRam& = FRE(-1)
  93.    NeededRam& = ((scrWidth%/8)*scrHeight%*(iDepth%+1))+5000
  94.    IF AvailRam& < NeededRam& THEN
  95.       loadError$ = "Not enough free ram"
  96.       GOTO Lcleanup
  97.    END IF
  98.    kk = 1
  99.    IF scrWidth% > 320 THEN kk = kk + 1
  100.    IF scrHeight% > 200  THEN kk = kk + 2
  101.    SCREEN 2,scrWidth%,scrHeight%,iDepth%,kk
  102.    WINDOW 2,"Puzzle Maker",,7,2
  103.    LINE (0,0)-(200,100),,bf:GET (0,0)-(200,100),box%
  104.    CLS
  105.    GOSUB GetScrAddrs
  106. ELSEIF tt$ = "CMAP" THEN
  107.    foundCMAP = 1
  108.    rLen& = xRead&(fHandle&,cbuf&,icLen&)
  109.    FOR kk = 0 TO nColors% - 1
  110.       red% = PEEK(cbuf&+(kk*3))
  111.       gre% = PEEK(cbuf&+(kk*3)+1)
  112.       blu% = PEEK(cbuf&+(kk*3)+2)
  113.       regTemp% = (red%*16)+(gre%)+(blu%/16)
  114.       scolor!(kk,1)=red%/255:scolor!(kk,2)=gre%/255:scolor!(kk,3)=blu%/255
  115.       POKEW(ctab&+(2*kk)),regTemp%
  116.    NEXT
  117. ELSEIF tt$ = "CAMG" THEN
  118.    foundCAMG = 1
  119.    rLen& = xRead&(fHandle&,inbuf&,icLen&)
  120.    camgModes& = PEEKL(inbuf&)
  121. ELSEIF tt$ = "CCRT" THEN
  122.    foundCCRT = 1
  123.    rLen& = xRead&(fHandle&,inbuf&,icLen&)
  124.    ccrtDir%    = PEEKW(inbuf&)
  125.    ccrtStart%  = PEEK(inbuf& + 2)
  126.    ccrtEnd%    = PEEK(inbuf& + 3)
  127.    ccrtSecs&   = PEEKL(inbuf& + 4)
  128.    ccrtMics&   = PEEKL(inbuf& + 8)
  129. ELSEIF tt$ = "BODY" THEN 
  130.    foundBODY = 1 
  131.    IF iCompr% = 0 THEN
  132.       FOR rr = 0 TO iHeight% -1
  133.          FOR pp = 0 TO iDepth% -1
  134.             scrRow& = bPlane&(pp)+(rr*scrRowBytes%)
  135.             rLen& = xRead&(fHandle&,scrRow&,iRowBytes%)   
  136.          NEXT
  137.       NEXT
  138.    ELSEIF iCompr% = 1 THEN
  139. FOR rr = 0 TO iHeight% -1
  140. FOR pp = 0 TO iDepth% -1
  141. scrRow& = bPlane&(pp)+(rr*scrRowBytes%)
  142. bCnt% = 0            
  143. WHILE (bCnt% < iRowBytes%)
  144. rLen& = xRead&(fHandle&,inbuf&,1)
  145. inCode% = PEEK(inbuf&)
  146. IF inCode% < 128 THEN
  147. rLen& = xRead&(fHandle&,scrRow& + bCnt%, inCode%+1)
  148. bCnt% = bCnt% + inCode% + 1
  149. ELSEIF inCode% > 128 THEN
  150. rLen& = xRead&(fHandle&,inbuf&,1)   
  151. inByte% = PEEK(inbuf&)
  152. FOR kk = bCnt% TO bCnt% + 257 - inCode%
  153. POKE(scrRow&+kk),inByte%
  154. NEXT   
  155. bCnt% = bCnt% + 257 - inCode%
  156. END IF
  157. WEND
  158. NEXT
  159. NEXT         
  160.    ELSE
  161.       loadError$ = "Unknown compression algorithm"
  162.       GOTO Lcleanup
  163.    END IF
  164. ELSE 
  165.    FOR kk = 1 TO icLen&
  166.       rLen& = xRead&(fHandle&,inbuf&,1)
  167.    NEXT
  168.    IF (icLen& OR 1) = icLen& THEN 
  169.       rLen& = xRead&(fHandle&,inbuf&,1)
  170.    END IF      
  171. END IF
  172. IF foundBMHD AND foundCMAP AND foundBODY THEN
  173.    GOTO GoodLoad
  174. END IF
  175. IF rLen&> 0 THEN GOTO ChunkLoop
  176. IF rLen& < 0 THEN 
  177.    loadError$ = "Read error"
  178.    GOTO Lcleanup
  179. END IF   
  180. IF (foundBMHD=0) OR (foundBODY=0) OR (foundCMAP=0) THEN
  181.    loadError$ = "Needed ILBM chunks not found"
  182.    GOTO Lcleanup
  183. END IF
  184. GoodLoad:
  185. loadError$ = ""
  186. IF foundCMAP THEN 
  187.    CALL LoadRGB4&(sViewPort&,ctab&,nColors%)
  188. END IF
  189. Lcleanup:
  190. IF fHandle& <> 0 THEN CALL xClose&(fHandle&)
  191. IF mybuf& <> 0 THEN CALL FreeMem&(mybuf&,mybufsize&)
  192. RETURN
  193. SavePuzzle:
  194. zz=MOUSE(0)
  195. WHILE MOUSE(0)=0:WEND
  196. x=MOUSE(1):y=MOUSE(2)
  197. PUT (x,y),box%
  198. WHILE MOUSE(0)<0
  199.   x1=MOUSE(1):y1=MOUSE(2)
  200.   IF (x1<>x OR y1<>y) AND x1<117 AND y1<88 THEN PUT (x,y),box%:PUT (x1,y1),box%:x=x1:y=y1
  201. WEND
  202. PUT (x1,y1),box%
  203. FOR c=0 TO 4
  204. FOR r=0 TO 9
  205. GET (x1+r*20,y1+c*20)-(x1+r*20+19,y1+c*20+19),piece%(0,c*10+r)
  206. NEXT
  207. NEXT
  208. WINDOW CLOSE 2
  209. SCREEN CLOSE 2
  210. WINDOW OUTPUT 1
  211. CLS
  212. PRINT "Please wait..."
  213. FOR i=0 TO 49
  214.   FOR j=3 TO 202
  215.     s$(i)=s$(i)+MKI$(piece%(j,i))
  216.   NEXT
  217. NEXT
  218. INPUT "Puzzle filename";f$
  219. f$="df0:"+f$+".pzl"
  220. OPEN f$ FOR OUTPUT AS #1
  221. PRINT#1,"BPFF"
  222. FOR i=0 TO 31
  223.   PRINT#1,scolor!(i,1),scolor!(i,2),scolor!(i,3)
  224. NEXT
  225. FOR i=0 TO 49
  226.   PRINT#1,s$(i);
  227. NEXT
  228. FOR i=0 TO 49
  229.   FOR j=0 TO 203
  230.     PRINT#1,MKI$(piece%(j,i));
  231.   NEXT
  232. NEXT
  233. PRINT#1,"0"
  234. CLOSE #1
  235. KILL f$+".info"
  236. PRINT "Puzzle ready to play.":END
  237. GetScrAddrs:
  238.    sWindow&   = WINDOW(7)
  239.    sScreen&   = PEEKL(sWindow& + 46)
  240.    sViewPort& = sScreen& + 44
  241.    sRastPort& = sScreen& + 84
  242.    sColorMap& = PEEKL(sViewPort& + 4)
  243.    colorTab&  = PEEKL(sColorMap& + 4)
  244.    sBitMap&   = PEEKL(sRastPort& + 4)
  245.    scrWidth%  = PEEKW(sScreen& + 12)
  246.    scrHeight% = PEEKW(sScreen& + 14)
  247.    scrDepth%  = PEEK(sBitMap& + 5)
  248.    nColors%   = 2^scrDepth%
  249.    FOR kk = 0 TO scrDepth% - 1
  250.       bPlane&(kk) = PEEKL(sBitMap&+8+(kk*4))
  251.    NEXT
  252. RETURN
  253.  
  254.